Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH4/SRC/REDUCEF.FRM

Visual Basic Form | 1997-01-03 | 14.4 KB | 472 lines

VERSION 4.00
Begin VB.Form ReduceForm
   Caption         =   "Reduce"
   ClientHeight    =   5205
   ClientLeft      =   1110
   ClientTop       =   1050
   ClientWidth     =   6945
   Height          =   5895
   Left            =   1050
   LinkTopic       =   "Form1"
   ScaleHeight     =   347
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   463
   Top             =   420
   Width           =   7065
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      Height          =   2310
      Index           =   2
      Left            =   4620
      Picture         =   "REDUCEF.frx":0000
      ScaleHeight     =   150
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   150
      TabIndex        =   2
      Top             =   2880
      Width           =   2310
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      Height          =   2310
      Index           =   1
      Left            =   4620
      Picture         =   "REDUCEF.frx":0446
      ScaleHeight     =   150
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   150
      TabIndex        =   1
      Top             =   240
      Width           =   2310
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      Height          =   4560
      Index           =   0
      Left            =   0
      Picture         =   "REDUCEF.frx":088C
      ScaleHeight     =   300
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   300
      TabIndex        =   0
      Top             =   360
      Width           =   4560
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   4080
      Top             =   4680
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      CancelError     =   -1  'True
   End
   Begin VB.Label Label1
      Alignment       =   2  'Center
      Caption         =   "ShrinkPicture Subroutine"
      Height          =   255
      Index           =   2
      Left            =   4620
      TabIndex        =   5
      Top             =   2640
      Width           =   2310
   End
   Begin VB.Label Label1
      Alignment       =   2  'Center
      Caption         =   "PaintPicture Method"
      Height          =   255
      Index           =   1
      Left            =   4620
      TabIndex        =   4
      Top             =   0
      Width           =   2310
   End
   Begin VB.Label Label1
      Alignment       =   2  'Center
      Caption         =   "Original Image"
      Height          =   255
      Index           =   0
      Left            =   0
      TabIndex        =   3
      Top             =   120
      Width           =   4500
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuScaleMnu
      Caption         =   "&Scale"
      Enabled         =   0   'False
      Begin VB.Menu mnuScale
         Caption         =   "1/&2x"
         Checked         =   -1  'True
         Index           =   2
      End
      Begin VB.Menu mnuScale
         Caption         =   "1/&3x"
         Index           =   3
      End
      Begin VB.Menu mnuScale
         Caption         =   "1/&4x"
         Index           =   4
      End
      Begin VB.Menu mnuScale
         Caption         =   "1/&8x"
         Index           =   8
      End
   End
Attribute VB_Name = "ReduceForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim SysPalSize As Integer
Dim NumStaticColors As Integer
Dim StaticColor1 As Integer
Dim StaticColor2 As Integer
Dim LogPal As Integer
Dim palentry(0 To 255) As PALETTEENTRY
Dim wid As Long
Dim hgt As Long
Dim bytes() As Byte
Dim ScaleFactor As Integer
' ************************************************
' Draw the reduced images at the proper scale.
' ************************************************
Sub DrawImages()
Dim wid As Single
Dim hgt As Single
Dim x0 As Single
Dim y0 As Single
Dim i As Integer
    WaitStart
    ' Reduce using PaintPicture.
    wid = Pict(0).ScaleWidth / ScaleFactor
    hgt = Pict(0).ScaleHeight / ScaleFactor
    x0 = (Pict(1).ScaleWidth - wid) / 2
    y0 = (Pict(1).ScaleHeight - hgt) / 2
    Pict(1).Cls
    Pict(1).PaintPicture Pict(0).Image, _
        x0, y0, wid, hgt
    DoEvents
    ' Reduce using ShrinkPicture.
    wid = Pict(0).ScaleWidth / ScaleFactor
    hgt = Pict(0).ScaleHeight / ScaleFactor
    x0 = (Pict(2).ScaleWidth - wid) / 2
    y0 = (Pict(2).ScaleHeight - hgt) / 2
    Pict(2).Cls
    ShrinkPicture Pict(0), Pict(2), _
        0, 0, _
        Pict(0).ScaleWidth - 1, Pict(0).ScaleHeight - 1, _
        x0, y0, x0 + wid - 1, y0 + hgt - 1
    DoEvents
    ' Let each image repair its palette if needed.
    For i = 0 To 2
        Pict(i).ZOrder
        DoEvents
    Next i
    WaitEnd
End Sub
' ************************************************
' Shrink the picture in from_pic and place it
' in to_pic.
' ************************************************
Sub ShrinkPicture( _
    ByVal from_pic As Control, ByVal to_pic As Control, _
    ByVal fx1 As Integer, ByVal fy1 As Integer, _
    ByVal fx2 As Integer, ByVal fy2 As Integer, _
    ByVal tx1 As Integer, ByVal ty1 As Integer, _
    ByVal tx2 As Integer, ByVal ty2 As Integer)
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim from_bytes() As Byte
Dim to_bytes() As Byte
Dim from_wid As Long
Dim from_hgt As Long
Dim to_wid As Long
Dim to_hgt As Long
Dim xscale As Single
Dim yscale As Single
Dim tx As Integer
Dim ty As Integer
Dim x1 As Integer
Dim y1 As Integer
Dim x2 As Integer
Dim y2 As Integer
Dim X As Integer
Dim Y As Integer
Dim clr As Integer
    ' Compute the scaling parameters.
    xscale = (tx2 - tx1) / (fx2 - fx1)
    yscale = (ty2 - ty1) / (fy2 - fy1)
    ' Get from_pic's pixels.
    hbm = from_pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    from_wid = bm.bmWidthBytes
    from_hgt = bm.bmHeight
    ReDim from_bytes(0 To from_wid - 1, 0 To from_hgt - 1)
    status = GetBitmapBits(hbm, from_wid * from_hgt, from_bytes(0, 0))
    ' Get to_pic's pixels.
    hbm = to_pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    to_wid = bm.bmWidthBytes
    to_hgt = bm.bmHeight
    ReDim to_bytes(0 To to_wid - 1, 0 To to_hgt - 1)
    status = GetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))

    ' Skrink the image.
    For ty = ty1 To ty2 - 1
        y1 = Int((ty - ty1) / yscale + fy1)
        y2 = Int((ty + 1 - ty1) / yscale + fy1) - 1
        For tx = tx1 To tx2 - 1
            x1 = Int((tx - tx1) / xscale + fx1)
            x2 = Int((tx + 1 - tx1) / xscale + fx1) - 1
            ' Average the values within the
            ' from_pic box (x1, y1) - (x2, y2).
            clr = 0
            For Y = y1 To y2
                For X = x1 To x2
                    clr = clr + palentry(from_bytes(X, Y)).peRed
                Next X
            Next Y
            clr = clr / (x2 - x1 + 1) / (y2 - y1 + 1)
            to_bytes(tx, ty) = NearestNonstaticGray(clr)
        Next tx
    Next ty
    ' Update from_pic.
    status = SetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))
    to_pic.Refresh
End Sub
' ***********************************************
' Load the control's palette so the non-static
' colors are grays. Map the logical palette to
' match the system palette. Convert the image to
' use the non-static grays.
' Set the following module global variables.
'   LogPal      Image logical palette handle.
'   palentry()  Image logical palette entries.
'   wid         Width of image.
'   hgt         Height of image.
'   bytes(1 To wid, 1 To hgt)
'               Image pixel values.
' ***********************************************
Sub MatchGrayPalette(pic As Control)
Dim sys(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim X As Integer
Dim Y As Integer
Dim gray As Single
Dim dgray As Single
Dim c As Integer
Dim clr As Integer
    ' Make sure pic has the foreground palette.
    pic.ZOrder
    i = RealizePalette(pic.hdc)
    DoEvents
    ' Get the system palette entries.
    i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))

    ' Get the image pixels.
    hbm = pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim bytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Make the logical palette as big as possible.
    LogPal = pic.Picture.hPal
    If ResizePalette(LogPal, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If
    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        palentry(i) = sys(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        palentry(i) = sys(i)
    Next i
    i = SetPaletteEntries(LogPal, 0, SysPalSize, palentry(0))
    ' Insert the non-static grays.
    gray = 0
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    For i = StaticColor1 + 1 To StaticColor2 - 1
        c = gray
        gray = gray + dgray
        With palentry(i)
            .peRed = c
            .peGreen = c
            .peBlue = c
        End With
    Next i
    i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))
    ' Recreate the image using the new colors.
    For Y = 1 To hgt
        For X = 1 To wid
            clr = bytes(X, Y)
            With sys(clr)
                c = (CInt(.peRed) + .peGreen + .peBlue) / 3
            End With
            bytes(X, Y) = NearestNonstaticGray(c)
        Next X
    Next Y
    status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Realize the gray palette.
    i = RealizePalette(pic.hdc)
    pic.Refresh
End Sub
' ************************************************
' Return the index of the nonstatic gray closest
' to the given value (assuming the non-static
' colors are a gray scale created by
' MatchGrayPalette).
' ************************************************
Function NearestNonstaticGray(c As Integer) As Integer
Dim dgray As Single
    If c < 0 Then
        c = 0
    ElseIf c > 255 Then
        c = 255
    End If
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    NearestNonstaticGray = c / dgray + StaticColor1 + 1
End Function
Private Sub Form_Load()
Dim i As Integer
    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If
    ' Get system palette size and # static colors.
    SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
    NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
    StaticColor1 = NumStaticColors \ 2 - 1
    StaticColor2 = SysPalSize - NumStaticColors \ 2
    ' Make the pictures all use gray palettes.
    ScaleFactor = 2
    Me.Show
    DoEvents
    WaitStart
    For i = 1 To 2
        MatchGrayPalette Pict(i)
    Next i
    DoEvents
    ' Let each image repair its palette if needed.
    For i = 0 To 2
        Pict(i).ZOrder
        DoEvents
    Next i
    WaitEnd
End Sub
' ***********************************************
' Reset the cursors for the form and all the
' picture boxes.
' ***********************************************
Sub WaitEnd()
Dim i As Integer
    MousePointer = vbDefault
    For i = 0 To 2
        Pict(i).MousePointer = vbDefault
    Next i
End Sub
' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
Dim i As Integer
    MousePointer = vbHourglass
    For i = 0 To 2
        Pict(i).MousePointer = vbHourglass
    Next i
    DoEvents
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub
' ***********************************************
' Load a new image file.
' ***********************************************
Private Sub mnuFileLoad_Click()
Dim fname As String
    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.filename = "*.BMP;*.ICO;*.RLE;*.WMF;*.DIB"
    FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    FileDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)
    ' Load the picture.
    WaitStart
    LoadFromPict fname
    mnuScaleMnu.Enabled = True
    mnuScale_Click 2
    WaitEnd
End Sub
' ***********************************************
' Load the indicated file and prepare to work
' with its palette.
' ***********************************************
Sub LoadFromPict(fname As String)
Dim status As Long
    On Error GoTo LoadFileError
    Pict(0).Picture = LoadPicture(fname)
    On Error GoTo 0

    MatchGrayPalette Pict(0)
    Caption = "Reduce [" & fname & "]"
    Exit Sub
LoadFileError:
    Beep
    MsgBox "Error loading file " & fname & "." & _
        vbCrLf & Error$
    Exit Sub
End Sub
' ************************************************
' Redraw the images at the new scale.
' ************************************************
Private Sub mnuScale_Click(Index As Integer)
    mnuScale(ScaleFactor).Checked = False
    ScaleFactor = Index
    mnuScale(ScaleFactor).Checked = True
    DrawImages
End Sub